home *** CD-ROM | disk | FTP | other *** search
/ Linux Cubed Series 3: Developer Tools / Linux Cubed Series 3 - Developer Tools.iso / devel / lang / lisp / stk-3.002 / stk-3 / STk-3.1 / Demos / hbrowse.stklos < prev    next >
Encoding:
Text File  |  1996-07-23  |  3.2 KB  |  110 lines
  1. #!/bin/sh
  2. :;exec /usr/local/bin/stk -f "$0" "$@"
  3. ;;;;
  4. ;;;; h b r o w s e         -- A HTML browser
  5. ;;;;
  6. ;;;; Copyright ⌐ 1993-1996 Erick Gallesio - I3S-CNRS/ESSI <eg@unice.fr>
  7. ;;;; 
  8. ;;;; Permission to use, copy, and/or distribute this software and its
  9. ;;;; documentation for any purpose and without fee is hereby granted, provided
  10. ;;;; that both the above copyright notice and this permission notice appear in
  11. ;;;; all copies and derived works.  Fees for distribution or use of this
  12. ;;;; software or derived works may only be charged with express written
  13. ;;;; permission of the copyright holder.  
  14. ;;;; This software is provided ``as is'' without express or implied warranty.
  15. ;;;;
  16. ;;;;           Author: Erick Gallesio [eg@unice.fr]
  17. ;;;;    Creation date: 31-Aug-1995 15:15
  18. ;;;; Last file update: 23-Jul-1996 09:49
  19. ;;;;
  20.  
  21. (require "Tk-classes")
  22. (require "Basics")
  23. (require "html")
  24.  
  25. (expand-heap 100000) ; but far lower than netscape ;-)
  26.  
  27. ;;;
  28. ;;; <Gauge> class definition 
  29. ;;;
  30. ;;; I don't use the <Canvas> class to avoid its (long) loading.
  31. ;;; Only a little bit of canvas capabilities are used here
  32.  
  33. (define-class <Gauge> (<Tk-simple-widget> <Tk-sizeable>)
  34.   ((foreground  :accessor foreground :initform "red" :init-keyword :foreground)))
  35.  
  36. (define-method tk-constructor ((self <Gauge>))
  37.   Tk:canvas)
  38.  
  39. (define-method initialize ((self <Gauge>) initargs)
  40.   (next-method)
  41.   (slot-set! self 'highlight-thickness 0)
  42.   ((slot-ref self 'Id) 'create 'line 0 0 0 0
  43.                :fill (foreground self)
  44.                :width (* 2 (+ (height self) 2))))
  45.  
  46. (define (update-gauge g percent)
  47.   ((slot-ref g 'Id) 'coords "1" 0 0 (quotient (* (width g) percent) 100) 0)
  48.   (update))
  49.  
  50. ;;;
  51. ;;; Make interface
  52. ;;;
  53. (let ((loc (make <Labeled-entry> 
  54.          :title "Location:" 
  55.          :text-variable '*location*
  56.          :font "fixed"))
  57.       (txt (make <Scroll-text> 
  58.          :font "fixed"
  59.          :width 80 
  60.          :height 45)))
  61.  
  62.   (bind (Id loc) "<Return>" (lambda () (Html:view-url (Id txt) (value loc))))
  63.   (pack loc :expand #t :fill "x"    :padx 30 :pady 4)
  64.   (pack txt :expand #t :fill "both")
  65.  
  66.   (let* ((f     (make <Frame>))
  67.      (lab   (make <Label> :parent f :anchor "w"))
  68.      (gauge (make <Gauge> :width 200 :height 10 :background "blue")))
  69.     (pack lab   :padx 30 :pady 4 :side "left")
  70.     (pack gauge :padx 10 :side "right")
  71.     (pack f     :fill "x")
  72.     
  73.     ;; See if a file was specified 
  74.     (when (> *argc* 0)
  75.     (set! *location* (car *argv*))
  76.     (Html:view-url (Id txt) *location*))
  77.  
  78.     ;; Initialize hooks
  79.     (let ((counter    0)
  80.       (pos         0))
  81.       (set! html:hook-formatting 
  82.         (lambda ()
  83.           (when (= counter 20)
  84.         (set! pos (modulo (+ pos 5) 105))
  85.         (set! counter 0)
  86.         (update-gauge gauge pos))
  87.           (set! counter (+ counter 1))))
  88.  
  89.       (set! html:hook-start-loading
  90.         (lambda ()
  91.           (slot-set! txt 'cursor "watch")
  92.           (slot-set! lab 'text "Loading Document ...")
  93.           (update)))
  94.     
  95.       (set! html:hook-stop-loading 
  96.         (lambda ()
  97.           (update-gauge gauge 0)
  98.           (slot-set! lab 'text "Document done.")
  99.           (slot-set! txt 'cursor "top_left_arrow")
  100.           (after 5000 (lambda () (slot-set! lab 'text "")))))
  101.  
  102.       (set! html:hook-title 
  103.         (lambda (value)
  104.           (slot-set! *top-root* 'title value)))
  105.  
  106.       (set! html:hook-location
  107.         (lambda (value)
  108.           (set! *location* value))))))
  109.  
  110.